home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
bitvecs.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
7KB
|
261 lines
/* $Id: bitvecs.c,v 1.4 1992/01/09 22:28:42 pab Exp $
*
* $Log: bitvecs.c,v $
* Revision 1.4 1992/01/09 22:28:42 pab
* Fixed for low tag ints
*
* Revision 1.3 1991/12/22 15:13:49 pab
* Xmas revision
*
* Revision 1.2 1991/09/11 12:07:00 pab
* 11/9/91 First Alpha release of modified system
*
* Revision 1.1 1991/08/12 16:49:26 pab
* Initial revision
*
* Revision 1.4 1991/02/11 21:24:13 pab
* tidied up...
*
* Revision 1.3 1991/02/04 17:33:39 kjp
* classof() standardisation.
*
* Revision 1.2 1990/11/29 22:45:19 pab
* Got vector arithmetic right. added integer->bit-vector
* NB: vectors indexed from 0. always have been. Always will be.
*
*/
/* ******************************************************************** */
/* bit-vectors.c Copyright (C) Codemist and University of Bath 1990 */
/* */
/* Just so */
/* ******************************************************************** */
/*
* Change Log:
* Version 1, September 1990
* 28/11/90 added bit-vector->integer
*/
#include <stdio.h>
#include "funcalls.h"
#include "defs.h"
#include "structs.h"
#include "global.h"
#include "error.h"
#include "allocate.h"
#include "class.h"
#include "modboot.h"
#include "bootstrap.h"
static LispObject Bit_Vector;
EUFUN_1( Fn_make_bit_vector, lisplen)
{
LispObject new;
int bytes,len;
if (!is_fixnum(lisplen))
CallError(stacktop,"make-bit-vector: bad size",lisplen,NONCONTINUABLE);
len = intval(lisplen);
if (len <= 0)
CallError(stacktop,"make-bit-vector: bad size",lisplen,NONCONTINUABLE);
bytes = len/8 + 1;
new = allocate_c_object(stacktop,0,((int)sizeof(int))+ bytes);
/* No lisp slots */
lval_classof(new) = Bit_Vector;
*((int *) &(new->C_OBJECT.first_c_byte)) = len;
for (len = 0 ; len < bytes ; len++)
((char *) &(new->C_OBJECT.first_c_byte))[sizeof(int)+len] = 0;
return(new);
}
EUFUN_CLOSE
EUFUN_1( Fn_bit_vector_p, obj)
{
extern LispObject Fn_subclassp(LispObject*);
if (EUCALL_2(Fn_subclassp,classof(obj),Bit_Vector) == nil) return(nil);
return(lisptrue);
}
EUFUN_CLOSE
EUFUN_1( Fn_bit_vector_length, v)
{
if (EUCALL_1(Fn_bit_vector_p,v) == nil)
CallError(stacktop,"bit-vector-length: bad bit vector",v,NONCONTINUABLE);
/* v = ARG_0(stackbase); /* Not needed as Fn_vector_p cannot GC?? */
return(allocate_integer(stacktop, *(int *) &((v->C_OBJECT.first_c_byte))));
}
EUFUN_CLOSE
EUFUN_2( Fn_bit_vector_ref, v, i)
{
int index,byte,bit;
int size;
if (EUCALL_1(Fn_bit_vector_p,v) == nil)
CallError(stacktop,"bit-vector-ref: non bit-vector",v,NONCONTINUABLE);
/* v = ARG_0(stackbase); /* Not needed as Fn_vector_p cannot GC?? */
size = *((int *) &(v->C_OBJECT.first_c_byte));
if (!is_fixnum(i))
CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
index = intval(i);
if (index < 0 || index >= size)
CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
byte = index/8;
bit = index%8;
if ((1 << bit) &
*(((char *) &(v->C_OBJECT.first_c_byte)) + sizeof(int) + byte))
return(allocate_integer(stacktop,1));
return(allocate_integer(stacktop,0));
}
EUFUN_CLOSE
EUFUN_3( Fn_bit_vector_ref_setter, v, i, val)
{
int index,byte,bit;
int size,state;
if (EUCALL_1(Fn_bit_vector_p,v) == nil)
CallError(stacktop,"bit-vector-ref: non bit-vector",v,NONCONTINUABLE);
size = *((int *) &(v->C_OBJECT.first_c_byte));
if (!is_fixnum(i))
CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
index = intval(i);
if (index < 0 || index >= size)
CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
if (!is_fixnum(val))
CallError(stacktop,
"(setter bit-vector-ref): bad bit value",val,NONCONTINUABLE);
if ((state = intval(val)) != 0 && state != 1)
CallError(stacktop,
"(setter bit-vector-ref): bad bit value",val,NONCONTINUABLE);
byte = index/8;
bit = index%8;
if (state == 1)
*(((char *) &(v->C_OBJECT.first_c_byte)) + sizeof(int) + byte)
|= (char) (1 << bit);
else
*(((char *) &(v->C_OBJECT.first_c_byte)) + sizeof(int) + byte)
&= (char) ~(1 << bit);
return(v);
}
EUFUN_CLOSE
/* conver intgers to bit-vectors */
EUFUN_1( Fn_integer_to_bit_vector, x)
{
LispObject vect;
int i;
unsigned char v_buf[sizeof(int)];
unsigned char *v_ptr;
EUCALLSET_1(vect, Fn_make_bit_vector,
allocate_integer(stacktop,sizeof(int) * 8));
x = ARG_0(stackbase);
bcopy((unsigned char *) &(intval(x)), v_buf,sizeof(int));
v_ptr = ((unsigned char *) &(vect->C_OBJECT.first_c_byte)) + sizeof(int);
/* Hmm, let's assume that this is big-endian */
#if 1
for (i=0; i < sizeof(int) ; i++)
{
v_ptr[i] = v_buf[(sizeof(int) - i) - 1];
}
#else
for (i=0; i < sizeof(int) ; i++)
v_ptr[sizeof(int)-i-1] = v_buf[(sizeof(int) - 1) - 1];
#endif
return vect;
}
EUFUN_CLOSE
/* Print method... */
EUFUN_2( Md_generic_prin, v, str)
{
int i,max;
if (!is_stream(str))
CallError(stacktop,"generic-prin: bad stream",str,NONCONTINUABLE);
fprintf(str->STREAM.handle,"#<bit-vector: ");
max = *((int *)&(v->C_OBJECT.first_c_byte));
for (i=0; i<max; ++i) {
int byte,bit;
byte = i/8;
bit = i%8;
fputc(((1 << bit)
& *(((char *) &(v->C_OBJECT.first_c_byte))
+ sizeof(int) + byte) ? '1' : '0'),str->STREAM.handle);
}
fprintf(str->STREAM.handle,">");
return(v);
}
EUFUN_CLOSE
#define BIT_VECTORS_ENTRIES (8)
MODULE Module_bit_vectors;
LispObject Module_bit_vectors_values[BIT_VECTORS_ENTRIES];
void initialise_bit_vectors(LispObject *stacktop)
{
extern LispObject Primitive_Class;
extern LispObject generic_generic_prin;
extern void set_anon_associate(LispObject *,LispObject,LispObject);
LispObject get,set;
open_module(stacktop,&Module_bit_vectors,Module_bit_vectors_values,
"bit-vectors",BIT_VECTORS_ENTRIES);
gen_class(stacktop,&Bit_Vector,"bit-vector",Primitive_Class,Object);
add_root(&Bit_Vector);
(void) make_module_entry(stacktop,"bit-vector",Bit_Vector);
(void) make_module_function(stacktop,"make-bit-vector",Fn_make_bit_vector,1);
(void) make_module_function(stacktop,"bit-vector-p",Fn_bit_vector_p,1);
(void) make_module_function(stacktop,
"bit-vector-length",Fn_bit_vector_length,1);
(void) make_module_function(stacktop,
"integer->bit-vector",Fn_integer_to_bit_vector,1);
get = make_module_function(stacktop,"bit-vector-ref",Fn_bit_vector_ref,2);
STACK_TMP(get);
set = make_unexported_module_function(stacktop,"bit-vector-ref-setter",
Fn_bit_vector_ref_setter,3);
UNSTACK_TMP(get);
set_anon_associate(stacktop,get,set);
(void) make_module_function(stacktop,"generic_generic_prin,BitVector",
Md_generic_prin,2);
close_module();
}